perm filename CON4[AM,DBL] blob
sn#183505 filedate 1975-10-24 generic text, type T, neo UTF8
(FILECREATED "24-OCT-75 03:23:56" <LENAT>CON4.;42 81755
changes to: VIEW OBJ-EQUAL CON4COMS
previous date: "22-OCT-75 03:44:53" <LENAT>CON4.;40)
(LISPXPRINT (QUOTE CON4COMS)
T T)
[RPAQQ CON4COMS
((FNS BAG CLASS FORMAT IMATRIX INIT-C OSET PAIR STRUC VECTOR)
CONCEPTS
(VARS * CONCEPTS)
FACETS
(FNS * FACETS)
AUX-FACETS
(VARS * AUX-FACETS)
SUF-PARTS STRATEGY-PARTS XEQ-PARTS XS-PARTS OR-PARTS GINTPREDS ZMSG [COMS *
(LIST (CONS (QUOTE IFPROP)
(CONS (QUOTE ALL)
CONCEPTS]
(P (INIT-C))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA VECTOR STRUC PAIR OSET FORMAT CLASS BAG)
(NLAML WORTH VIEW UP TIES SUGG SPEC RESTRUC INV INTU INT-NOT INT INIT IN-RAN-OF IN-DOM-OF
GENL FILLIN2 FILLIN1 FILLIN EXS-NOT-BDY EXS-NOT EXS-BDY EXS DEFN-NOT DEFN D-R
CHECK2 CHECK1 CHECK ANAS ALGS]
(DEFINEQ
(BAG
[NLAMBDA X
(CONS (QUOTE BAG)
X])
(CLASS
[NLAMBDA X
(CONS (QUOTE CLASS)
X])
(FORMAT
[NLAMBDA Z
(CONS (QUOTE FORMAT)
Z])
(IMATRIX
[LAMBDA NIL 0])
(INIT-C
[LAMBDA (R1)
(MOVD (QUOTE OR)
(QUOTE ANY-OF))
(MOVD (QUOTE GETP)
(QUOTE FGETB))
(MOVD (QUOTE APPLY*)
(QUOTE APPLYB))
(MOVD (QUOTE APPEND)
(QUOTE ALL-OF))
(MOVD (QUOTE CAR)
(QUOTE IPRED))
(MOVD (QUOTE CADR)
(QUOTE IDEF))
(MOVD (QUOTE CDDDAR)
(QUOTE PINT))
(MOVD (QUOTE CAAR)
(QUOTE P-OP))
(MOVD (QUOTE CADAR)
(QUOTE P-B))
(MOVD (QUOTE CADDAR)
(QUOTE P-P))
(MOVD (QUOTE CDR)
(QUOTE P-V))
(MOVD (QUOTE CADDR)
(QUOTE IVAL))
(MOVD (QUOTE CDDR)
(QUOTE IFEATURES))
(MOVD (QUOTE CDADR)
(QUOTE IMAT))
(MOVD (QUOTE CADR)
(QUOTE IFEA))
(MOVD (QUOTE CAAR)
(QUOTE CSINT))
(MOVD (QUOTE CDR)
(QUOTE CSOTHERS))
(MOVD (QUOTE CAR)
(QUOTE CSBEST))
(MOVD (QUOTE CAR)
(QUOTE CINT))
(MOVD (QUOTE RPLACA)
(QUOTE RPLACINT))
(MOVD (QUOTE CADR)
(QUOTE COP))
(MOVD (QUOTE CADDR)
(QUOTE CB))
(MOVD (QUOTE CADDDR)
(QUOTE CP))
(MOVD (QUOTE CDR)
(QUOTE CACT))
(SETQ HCON (HARRAY 503))
(SETQ RANU (QUOTE DOUG))
(SETQ RANC (QUOTE ANYB))
(SETQQ RANF RAND-USER)
(SETQ CIRC (HARRAY 500))
(PUTHASH (QUOTE RAND-OBJ)
(QUOTE RAND-USER)
CIRC)
(PUTHASH (QUOTE RAND-USER)
(QUOTE RAND-CON)
CIRC)
(PUTHASH (QUOTE RAND-CON)
(QUOTE RAND-OBJ)
CIRC)
(SETQ OBJX (EXS OBJECT))
[MAPC CONCEPTS (FUNCTION (LAMBDA (B)
(PUTHASH B 1 HCON)
(PUTD B (COPY TRIVB))
(DEFB B]
[MAP (SETQ R1 (DRAND-PERMUTE (COPY CONCEPTS)))
(FUNCTION (LAMBDA (C)
(PUTHASH (CAR C)
(CADR C)
CIRC]
(PUTHASH (CAR (LAST R1))
(CAR R1)
CIRC)
[MAP (SETQ R1 (RAND-PERMUTE USERNAMES))
(FUNCTION (LAMBDA (C)
(PUTHASH (CAR C)
(CADR C)
CIRC]
(PUTHASH (CAR (LAST R1))
(CAR R1)
CIRC)
(CPRIN1 0 CRLF "There are " (LENGTH CONCEPTS)
" concepts in this incarnation of AM." CRLF)
(SETQ SUF1 (HARRAY 60))
(SETQ SUF2 (HARRAY 60))
(SETQ SWSUF (HARRAY 60))
[MAPC SUF-PARTS (FUNCTION (LAMBDA (FACET)
(PUTHASH FACET (PACK (LIST FACET 1))
SUF1)
(PUTHASH FACET (PACK (LIST FACET 2))
SUF2)
(PUTHASH (GETHASH FACET SUF2)
(GETHASH FACET SUF1)
SWSUF)
(PUTHASH (GETHASH FACET SUF1)
(GETHASH FACET SUF2)
SWSUF]
[MAPC FACETS (FUNCTION (LAMBDA (P)
(SETPROPLIST P (GETPROPLIST (GLUE (QUOTE ANYB)
P]
(CPRIN1 0 CRLF "Initialization completed. To start AM, type (START)" CRLF])
(OSET
[NLAMBDA X
(CONS (QUOTE OSET)
X])
(PAIR
[NLAMBDA X
(CONS (QUOTE PAIR)
X])
(STRUC
[NLAMBDA X
(CONS (QUOTE STRUC)
X])
(VECTOR
[NLAMBDA X
(CONS (QUOTE VECTOR)
X])
)
(RPAQQ CONCEPTS
(ACTIVE-GENL ACTIVE-SPEC ACTIVE-EXS-NOT-BDY ACTIVE ACTIVE-D-R ACTIVE-EXS ANYB ANYB-ALGS ANYB-ANAS ANYB-ANYP
ANYB-CHECK ANYB-CHECK1 ANYB-CHECK2 ANYB-D-R ANYB-DEFN ANYB-DEFN-NOT ANYB-DOMAIN ANYB-EXS
ANYB-EXS-BDY ANYB-EXS-NOT ANYB-EXS-NOT-BDY ANYB-FILLIN ANYB-FILLIN1 ANYB-FILLIN2 ANYB-GENL
ANYB-IN-DOM-OF ANYB-IN-RAN-OF ANYB-INIT ANYB-INT ANYB-INT-NOT ANYB-INTU ANYB-INV ANYB-RANGE
ANYB-RESTRUC ANYB-SPEC ANYB-SUGG ANYB-TIES ANYB-UP ANYB-VIEW ANYB-WORTH ANYTHING BAG-STRUC
BAG-STRUC-DELETE BAG-STRUC-INSERT BAG-STRUC-INTERSECT COALESCE COMPOSE COMPOSE-D-R COMPOSE-EXS
COMPOSE-EXS-D-R CONSTRUCTIVE EMPTY EMPTY-STRUC FINAL FIRST LIST-STRUC LIST-STRUC-DELETE
LIST-STRUC-INSERT LIST-STRUC-INTERSECT MULT-STRUC NON-EMPTY NONMULT-STRUC OBJ-EQUAL OBJECT
OBJECT-EXS OPERATION ORD-OBJ ORD-OBJ-EXS ORD-PAIR OSET-STRUC OSET-STRUC-DELETE OSET-STRUC-INSERT
OSET-STRUC-INTERSECT PREDICATE REAR RELATION REV-ORD-PAIR SET-STRUC SET-STRUC-DELETE
SET-STRUC-DIFF SET-STRUC-INSERT SET-STRUC-INTERSECT STRUCTURE STRUCTURE-DELETE STRUCTURE-DIFF
STRUCTURE-EQUAL STRUCTURE-EXS STRUCTURE-EXS-BDY STRUCTURE-INSERT STRUCTURE-INTERSECT
STRUCTURE-MEMB TRUTH-VAL UNORD-OBJ UNORD-OBJ-EXS))
(RPAQQ ACTIVE-GENL (FROM-FILE CON4))
(RPAQQ ACTIVE-SPEC (FROM-FILE CON4))
(RPAQQ ACTIVE-EXS-NOT-BDY (FROM-FILE CON4))
(RPAQQ ACTIVE (FROM-FILE CON4))
(RPAQQ ACTIVE-D-R (FROM-FILE CON4))
(RPAQQ ACTIVE-EXS (FROM-FILE CON4))
(RPAQQ ANYB (FROM-FILE CON4))
(RPAQQ ANYB-ALGS (FROM-FILE CON4))
(RPAQQ ANYB-ANAS (FROM-FILE CON4))
(RPAQQ ANYB-ANYP (FROM-FILE CON4))
(RPAQQ ANYB-CHECK (FROM-FILE CON4))
(RPAQQ ANYB-CHECK1 (FROM-FILE CON4))
(RPAQQ ANYB-CHECK2 (FROM-FILE CON4))
(RPAQQ ANYB-D-R (FROM-FILE CON4))
(RPAQQ ANYB-DEFN (FROM-FILE CON4))
(RPAQQ ANYB-DEFN-NOT (FROM-FILE CON4))
(RPAQQ ANYB-DOMAIN (FROM-FILE CON4))
(RPAQQ ANYB-EXS (FROM-FILE CON4))
(RPAQQ ANYB-EXS-BDY (FROM-FILE CON4))
(RPAQQ ANYB-EXS-NOT (FROM-FILE CON4))
(RPAQQ ANYB-EXS-NOT-BDY (FROM-FILE CON4))
(RPAQQ ANYB-FILLIN (FROM-FILE CON4))
(RPAQQ ANYB-FILLIN1 (FROM-FILE CON4))
(RPAQQ ANYB-FILLIN2 (FROM-FILE CON4))
(RPAQQ ANYB-GENL (FROM-FILE CON4))
(RPAQQ ANYB-IN-DOM-OF (FROM-FILE CON4))
(RPAQQ ANYB-IN-RAN-OF (FROM-FILE CON4))
(RPAQQ ANYB-INIT (FROM-FILE CON4))
(RPAQQ ANYB-INT (FROM-FILE CON4))
(RPAQQ ANYB-INT-NOT (FROM-FILE CON4))
(RPAQQ ANYB-INTU (FROM-FILE CON4))
(RPAQQ ANYB-INV (FOUT CON4))
(RPAQQ ANYB-RANGE (FROM-FILE CON4))
(RPAQQ ANYB-RESTRUC (FROM-FILE CON4))
(RPAQQ ANYB-SPEC (FROM-FILE CON4))
(RPAQQ ANYB-SUGG (FROM-FILE CON4))
(RPAQQ ANYB-TIES (FROM-FILE CON4))
(RPAQQ ANYB-UP (FROM-FILE CON4))
(RPAQQ ANYB-VIEW (FROM-FILE CON4))
(RPAQQ ANYB-WORTH (FROM-FILE CON4))
(RPAQQ ANYTHING (FROM-FILE CON4))
(RPAQQ BAG-STRUC (FROM-FILE CON4))
(RPAQQ BAG-STRUC-DELETE (FROM-FILE CON4))
(RPAQQ BAG-STRUC-INSERT (FROM-FILE CON4))
(RPAQQ BAG-STRUC-INTERSECT (FROM-FILE CON4))
(RPAQQ COALESCE (FROM-FILE CON4))
(RPAQQ COMPOSE (FROM-FILE CON4))
(RPAQQ COMPOSE-D-R (FROM-FILE CON4))
(RPAQQ COMPOSE-EXS (FROM-FILE CON4))
(RPAQQ COMPOSE-EXS-D-R (FROM-FILE CON4))
(RPAQQ CONSTRUCTIVE (FROM-FILE CON4))
(RPAQQ EMPTY (FROM-FILE CON4))
(RPAQQ EMPTY-STRUC (FROM-FILE CON4))
(RPAQQ FINAL (FROM-FILE CON4))
(RPAQQ FIRST (FROM-FILE CON4))
(RPAQQ LIST-STRUC (FROM-FILE CON4))
(RPAQQ LIST-STRUC-DELETE (FROM-FILE CON4))
(RPAQQ LIST-STRUC-INSERT (FROM-FILE CON4))
(RPAQQ LIST-STRUC-INTERSECT (FROM-FILE CON4))
(RPAQQ MULT-STRUC (FROM-FILE CON4))
(RPAQQ NON-EMPTY (FROM-FILE CON4))
(RPAQQ NONMULT-STRUC (FROM-FILE CON4))
(RPAQQ OBJ-EQUAL OBJ-EQUAL)
(RPAQQ OBJECT (FROM-FILE CON4))
(RPAQQ OBJECT-EXS (FROM-FILE CON4))
(RPAQQ OPERATION (FROM-FILE CON4))
(RPAQQ ORD-OBJ (FROM-FILE CON4))
(RPAQQ ORD-OBJ-EXS (FROM-FILE CON4))
(RPAQQ ORD-PAIR (FROM-FILE CON4))
(RPAQQ OSET-STRUC (FROM-FILE CON4))
(RPAQQ OSET-STRUC-DELETE (FROM-FILE CON4))
(RPAQQ OSET-STRUC-INSERT (FROM-FILE CON4))
(RPAQQ OSET-STRUC-INTERSECT (FROM-FILE CON4))
(RPAQQ PREDICATE (FROM-FILE CON4))
(RPAQQ REAR (FROM-FILE CON4))
(RPAQQ RELATION (FROM-FILE CON4))
(RPAQQ REV-ORD-PAIR (FROM-FILE CON4))
(RPAQQ SET-STRUC (FROM-FILE CON4))
(RPAQQ SET-STRUC-DELETE (FROM-FILE CON4))
(RPAQQ SET-STRUC-DIFF (FROM-FILE CON4))
(RPAQQ SET-STRUC-INSERT (FROM-FILE CON4))
(RPAQQ SET-STRUC-INTERSECT (FROM-FILE CON4))
(RPAQQ STRUCTURE (FROM-FILE CON4))
(RPAQQ STRUCTURE-DELETE (FROM-FILE CON4))
(RPAQQ STRUCTURE-DIFF (FROM-FILE CON4))
(RPAQQ STRUCTURE-EQUAL (FROM-FILE CON4))
(RPAQQ STRUCTURE-EXS (FROM-FILE CON4))
(RPAQQ STRUCTURE-EXS-BDY (FROM-FILE CON4))
(RPAQQ STRUCTURE-INSERT (FROM-FILE CON4))
(RPAQQ STRUCTURE-INTERSECT (FROM-FILE CON4))
(RPAQQ STRUCTURE-MEMB (FROM-FILE CON4))
(RPAQQ TRUTH-VAL (FROM-FILE CON4))
(RPAQQ UNORD-OBJ (FROM-FILE CON4))
(RPAQQ UNORD-OBJ-EXS (FROM-FILE CON4))
(RPAQQ FACETS
(ALGS ANAS CHECK CHECK1 CHECK2 D-R DEFN DEFN-NOT EXS EXS-BDY EXS-NOT EXS-NOT-BDY FILLIN FILLIN1 FILLIN2 GENL
IN-DOM-OF IN-RAN-OF INIT INT INT-NOT INTU INV RESTRUC SPEC SUGG TIES UP VIEW WORTH))
(DEFINEQ
(ALGS
[NLAMBDA (B BA1 BA2 BA3 BA4)
(POR (QUOTE ALGS)
B BA1 BA2 BA3 BA4])
(ANAS
[NLAMBDA (B BA1 BA2 BA3)
(PXEQ (QUOTE ANAS)
B BA1 BA2 BA3])
(CHECK
[NLAMBDA (B BA1 BA2 BA3 BA4 RS C1 PP P)
(AND (SETQ C1 (GETP (QUOTE CHECK)
(QUOTE CENT)))
(SETQ RS (RIPPLE-SIMULT B C1))
(SETQQ PP CHECK)
(OR (AND BA1 (FMEMB BA1 FACETS)
(SETQ PP BA1)
[SETQ RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(IS-CON-L (GLUE R BA1]
[NCONC RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(RIPPLE-SIMULT R C1]
(SETQ RS (INTERSECTION RS RS)))
T)
(SETQ GEXISTING (GETB B PP))
(PROGN [MAPC RS (FUNCTION (LAMBDA (Z)
(APPLYB Z (QUOTE CHECK1)
BA1 BA2 BA3]
[MAPC (DREVERSE RS)
(FUNCTION (LAMBDA (Z)
(APPLYB Z (QUOTE CHECK2)
BA1 BA2 BA3]
T])
(CHECK1
[NLAMBDA (B)
(PGET (QUOTE CHECK1)
B])
(CHECK2
[NLAMBDA (B)
(PGET (QUOTE CHECK2)
B])
(D-R
[NLAMBDA (B)
(PGET (QUOTE D-R)
B])
(DEFN
[NLAMBDA (B BA1 BA2 BA3 BA4 RS C1 ATMP)
(AND (SETQ C1 (GETP (QUOTE DEFN)
(QUOTE CENT)))
(SETQ RS (REVERSE (RIPPLE-SIMULT B C1)))
(GETB B (QUOTE DEFN))
(PROG NIL
L1 (OR (AND (APPLY* (QUOTE DEFN-NOT)
(CAR RS)
BA1 BA2 BA3)
(RETURN NIL))
(AND (SETQ ATMP (APPLYB (CAR RS)
(QUOTE DEFN)
BA1 BA2 BA3))
(RETURN ATMP))
(AND (SETQ RS (CDR RS))
(GO L1))
(RETURN NIL])
(DEFN-NOT
[NLAMBDA (B BA1 BA2 BA3 BA4 RS C1 ATMP)
(AND (SETQ C1 (GETP (QUOTE DEFN-NOT)
(QUOTE CENT)))
(SETQ RS (RIPPLE-SIMULT B C1))
(GETB B (QUOTE DEFN-NOT))
(SOME-EBP RS (QUOTE DEFN-NOT)
BA1 BA2 BA3])
(EXS
[NLAMBDA (B)
(PGET (QUOTE EXS)
B])
(EXS-BDY
[NLAMBDA (B)
(PGET (QUOTE EXS-BDY)
B])
(EXS-NOT
[NLAMBDA (B)
(PGET (QUOTE EXS-NOT)
B])
(EXS-NOT-BDY
[NLAMBDA (B)
(PGET (QUOTE EXS-NOT-BDY)
B])
(FILLIN
[NLAMBDA (B BA1 BA2 BA3 BA4 RS C1 PP)
(AND (SETQ C1 (GETP (QUOTE FILLIN)
(QUOTE CENT)))
(SETQ RS (RIPPLE-SIMULT B C1))
(SETQ PP (QUOTE FILLIN))
(OR (AND BA1 (FMEMB BA1 FACETS)
(SETQ PP BA1)
[SETQ RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(IS-CON-L (GLUE R BA1]
[NCONC RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(RIPPLE-SIMULT R C1]
(SETQ RS (INTERSECTION RS RS)))
T)
(SETQ GEXISTING (INIT-PART B PP))
(NCONCB B PP (NCONC [MAPCONC RS (FUNCTION (LAMBDA (Z)
(APPLYB Z (QUOTE FILLIN1)
BA1 BA2 BA3]
(MAPCONC (DREVERSE RS)
(FUNCTION (LAMBDA (Z)
(APPLYB Z (QUOTE FILLIN2)
BA1 BA2 BA3])
(FILLIN1
[NLAMBDA (B)
(PGET (QUOTE FILLIN1)
B])
(FILLIN2
[NLAMBDA (B)
(PGET (QUOTE FILLIN2)
B])
(GENL
[NLAMBDA (B)
(RIPPLE B (QUOTE GENL])
(IN-DOM-OF
[NLAMBDA (B)
(PGET (QUOTE IN-DOM-OF)
B])
(IN-RAN-OF
[NLAMBDA (B)
(PGET (QUOTE IN-RAN-OF)
B])
(INIT
[NLAMBDA (B)
(PGET (QUOTE INIT)
B])
(INT
[NLAMBDA (B BA1 BA2 BA3)
(PXEQ (QUOTE INT)
B BA1 BA2 BA3])
(INT-NOT
[NLAMBDA (B BA1 BA2 BA3)
(PXEQ (QUOTE INT-NOT)
B BA1 BA2 BA3])
(INTU
[NLAMBDA (B BA1 BA2 BA3)
(PXEQ (QUOTE INTU)
B BA1 BA2 BA3])
(INV
[NLAMBDA (B BA1 BA2 BA3 BA4)
(PXEQ (QUOTE INV)
B BA1 BA2 BA3 BA4])
(RESTRUC
[NLAMBDA (B)
(PGET (QUOTE RESTRUC)
B])
(SPEC
[NLAMBDA (B)
(RIPPLE B (QUOTE SPEC])
(SUGG
[NLAMBDA (B BA1 BA2 BA3)
(PXEQ (QUOTE SUGG)
B BA1 BA2 BA3])
(TIES
[NLAMBDA (B)
(PGET (QUOTE TIES)
B])
(UP
[NLAMBDA (B)
(PGET (QUOTE UP)
B])
(VIEW
[NLAMBDA (B BA1 BA2 BA3 BA4 RS C1) (* BA1 is the name of the type we wish
to convert the given to)
(* BA2 is the given structure to be
converted)
(* BA3 is the name of the given
structure's type)
(SETQ C1 (GETP (QUOTE VIEW)
(QUOTE CENT)))
(AND (SETQ RS (REVERSE (RIPPLE-SIMULT B C1)))
(GETB B (QUOTE VIEW))
(SOME-EBP RS (QUOTE VIEW)
B BA1 BA2 BA3 BA4])
(WORTH
[NLAMBDA (B)
(PGET (QUOTE WORTH)
B])
)
(RPAQQ AUX-FACETS (FILLIN1 FILLIN2 CHECK1 CHECK2))
(RPAQQ FILLIN1 NIL)
(RPAQQ FILLIN2 NIL)
(RPAQQ CHECK1 NIL)
(RPAQQ CHECK2 NIL)
(RPAQQ SUF-PARTS (FILLIN CHECK))
(RPAQQ STRATEGY-PARTS (FILLIN CHECK))
(RPAQQ XEQ-PARTS (DOMAIN DEFN-NOT ALGS ANAS CHECK CHECK1 CHECK2 FILLIN FILLIN1 FILLIN2 INT INT-NOT INTU INV SUGG VIEW
RESTRUC DEFN))
(RPAQQ XS-PARTS (DOMAIN DEFN-NOT VIEW ALGS ANAS CHECK1 CHECK2 DEFN FILLIN1 FILLIN2 INT INT-NOT INTU INV SUGG RESTRUC))
(RPAQQ OR-PARTS (DEFN DEFN-NOT ALGS VIEW))
(RPAQQ GINTPREDS (NON-EMPTY EMPTY COALESCED-STRUCTURE-EQUAL COALESCED-OBJ-EQUAL OBJ-EQUAL))
(RPAQQ ZMSG (* IN COALESE.ALGS, WE MUST REPLACE THE COALESCED BAI IN ALL PARTS OF THE NEW BEING, NNOT JUST IN
ALGS/DEFN PARTS))
(PUTPROPS ACTIVE-GENL GENL (ANYB-GENL)
FILLIN1 (PROG NIL (* guts missing)
(CPRIN1 5 " active-spec.fillin1 "))
WORTH (0))
(PUTPROPS ACTIVE-SPEC GENL (ANYB-SPEC)
FILLIN1 (PROG NIL (* guts missing)
(CPRIN1 5 " active-spec.fillin1 "))
WORTH (0))
(PUTPROPS ACTIVE-EXS-NOT-BDY GENL (ANYB-EXS-NOT-BDY)
FILLIN1 [NCONC
(AND
(GETB CS-B (QUOTE ALGS))
[SOME (GETB CS-B (QUOTE D-R))
(FUNCTION
(LAMBDA
(DR)
(AND (EVERY [SETQ
CROS
(MAPCAR (ALL-BUT-LAST DR)
(FUNCTION
(LAMBDA
(Z)
(COND
[(SETQ TMP3 (GETB Z (QUOTE EXS-BDY)))
(APPEND TMP3
(FIRSTN (LARGER 10
(LENGTH
TMP3))
(ACEX Z]
((ACEX Z]
(QUOTE LISTP))
CROS]
(PROG (TKNT CORG RLST (EKNT 0)
(NEKNT 0))
(CPRIN1 9 CRLF " Record of attempts to find non-examples: ")
(SETQ TKNT (IPLUS (SETQ CORG (CLOCK 2))
(ITIMES CS-INT 100)))
(SETQ RLST (LIST T))
[SETQ GTEMP127 (COND ((ISA CS-B (QUOTE PREDICATE))
(QUOTE GTEMP130))
(T (QUOTE GTEMP128]
L18
(SETQ GTEMP130 (MAPCAR CROS (QUOTE RANDQMEMB)))
(* GTEMP130 is a random vector from the space of possible arguments of
CS-B)
(SETQ GTEMP129 (APPEND (LIST (QUOTE APPLYB)
(KWOTE CS-B)
(Q ALGS))
GTEMP130))
(* GTEMP129 is the fully formed "call" on CS-B, with arguments
GTEMP130)
(COND ((SETQ GTEMP128 (EVAL (COPY GTEMP129)))
(* GTEMP128 is the value returned by this call on CS-B)
(CPRIN1 45 CRLF " An example (unsought) is: " (EVAL GTEMP127))
(* To get to this point, the call must have been OK; ie, an
example was found even though we didn't want one)
(SETQ EKNT (ADD1 EKNT))
(CPRIN1 9 " +")
(INCRB CS-B (QUOTE EXS)
(LIST (QUOTE VECTOR)
GTEMP130 GTEMP129 GTEMP128)))
(T (SETQ NEKNT (ADD1 NEKNT))
(CPRIN1 44 CRLF " A (sought) non-example is: " (EVAL GTEMP127)
)
(CPRIN1 9 " -")
(ATTACH (LIST (QUOTE VECTOR)
GTEMP130 GTEMP129 GTEMP128)
RLST)))
[COND ((OR (IGREATERP NEKNT 10)
(IGREATERP EKNT 25)
(IGREATERP (CLOCK 2)
TKNT))
(CPRIN1 9 CRLF " Found " NEKNT " non-examples (and " EKNT
" exs), in " (IQUOTIENT (IDIFFERENCE (CLOCK 2)
CORG)
1000.0)
" secs." CRLF)
[COND ((ILESSP (ADD1 EKNT)
NEKNT)
(BOOST (QUOTE FILLIN)
CS-B
(QUOTE GENL)))
((ILESSP (ITIMES 2 (ADD1 NEKNT))
(SUB1 EKNT))
(BOOST (QUOTE FILLIN)
CS-B
(QUOTE SPEC]
(RETURN (CDR (DREVERSE RLST]
(GO L18]
SUGG [APPEND (MAPCONC PAST (FUNCTION (LAMBDA
(PE)
(SETQ GTEMP39 (P-B PE))
(COND
((AND (EQ (P-P PE)
(QUOTE EXS))
(EQ (P-OP PE)
(QUOTE FILLIN))
(NULL (GETB GTEMP39 (QUOTE EXS)))
(ISA PE (QUOTE ACTIVE)))
(* That is, did we try and fail to fill in exs
of GTEMP39)
(SETQ GTEMP36 (LIST (QUOTE FILLIN)
GTEMP39
(QUOTE EXS-NOT-BDY)))
(SETQ GTEMP37 (SASSOC GTEMP36 PAST))
(* Did we try recently to fill in non-examples)
(COND
((NULL GTEMP37)
(* No, so let's suggest trying that)
(LIST (CONS (DOTPROD (GETB GTEMP39
(QUOTE WORTH))
(LIST .4 .1))
GTEMP36)))
[(GETB GTEMP39 (QUOTE EXS-NOT-BDY))
(* Yes, we tried and in fact succeeded)
(* We have tried to fill in examples and
non-examples of the Being, but failed to
find any non-examples. It is too
general.)
[SET-NTH (GETB GTEMP39 (QUOTE WORTH))
1
(AVG2 1
(CAR (GETB GTEMP39
(QUOTE WORTH]
(LIST (LIST (DOTPROD (GETB GTEMP39
(QUOTE WORTH))
(LIST 1.4 .5 .1))
(QUOTE FILLIN)
GTEMP39
(QUOTE SPEC]
(T (* Failed on both accounts, so the
problem is just too tough for now.)
NIL]
WORTH (0)
INIT (ANY-OF NIL))
(PUTPROPS ACTIVE GENL (ANYB)
SPEC (RELATION PREDICATE OPERATION)
WORTH (0)
DEFN (ANY-OF NIL)
UP (ANYB))
(PUTPROPS ACTIVE-D-R GENL (ANYB-D-R)
WORTH (0)
SPEC (COMPOSE-EXS-D-R COMPOSE-D-R))
(PUTPROPS ACTIVE-EXS GENL (ANYB-EXS)
FILLIN1 [NCONC (AND (GETB CS-B (QUOTE ALGS))
[SOME (GETB CS-B (QUOTE D-R))
(FUNCTION (LAMBDA (DR)
(AND (EVERY (SETQ CROS (MAPCAR (ALL-BUT-LAST DR)
(QUOTE ACEX)))
(QUOTE LISTP))
CROS]
(PROG (TKNT CORG RLST (EKNT 0)
(NEKNT 0))
(CPRIN1 9 CRLF " Record of attempts to find examples: ")
(SETQ TKNT (IPLUS (SETQ CORG (CLOCK 2))
(ITIMES CS-INT 100)))
(SETQ RLST (LIST T))
[SETQ GTEMP127 (COND ((ISA CS-B (QUOTE PREDICATE))
(QUOTE GTEMP130))
(T (QUOTE GTEMP128]
L18
(SETQ GTEMP130 (MAPCAR CROS (QUOTE RANDQMEMB)))
(* GTEMP130 is a random vector from the space of possible arguments of
CS-B)
(SETQ GTEMP129 (APPEND (LIST (QUOTE APPLYB)
(KWOTE CS-B)
(Q ALGS))
GTEMP130))
(* GTEMP129 is the fully formed "call" on CS-B, with arguments
GTEMP130)
[COND ((SETQ GTEMP128 (EVAL (COPY GTEMP129)))
(* GTEMP128 is the value returned by this call on CS-B)
(CPRIN1 44 CRLF " An ex (sought) is: " (EVAL GTEMP127))
(* To get to this point, the call must have been OK; ie, an
non-example was found even though we didn't want one)
(SETQ EKNT (ADD1 EKNT))
(CPRIN1 9 " +")
(ATTACH (LIST (QUOTE VECTOR)
GTEMP130 GTEMP129 GTEMP128)
RLST))
(T (SETQ NEKNT (ADD1 NEKNT))
(CPRIN1 9 " -")
(COND ((ILESSP NEKNT 10)
(CPRIN1 45 CRLF " An (unsought) non-ex is: "
(EVAL GTEMP127))
(INCRB CS-B (QUOTE EXS-NOT-BDY)
(LIST (QUOTE VECTOR)
GTEMP130 GTEMP129 GTEMP128]
[COND ((OR (IGREATERP NEKNT 150)
(IGREATERP EKNT 25)
(IGREATERP (CLOCK 2)
TKNT))
(CPRIN1 9 CRLF " Found " EKNT " examples (and " NEKNT
" non-exs), in " (IQUOTIENT (IDIFFERENCE (CLOCK 2)
CORG)
1000.0)
" secs." CRLF)
[COND ((ILESSP EKNT NEKNT)
(BOOST (QUOTE FILLIN)
CS-B
(QUOTE GENL)))
((ZEROP NEKNT)
(BOOST (QUOTE FILLIN)
CS-B
(QUOTE EXS-NOT-BDY]
(RETURN (CDR (DREVERSE RLST]
(GO L18]
SUGG [APPEND [MAPCONC CONCEPTS
(FUNCTION
(LAMBDA
(C)
(* This whole SUGG entry can be eliminated if desired.)
(AND (ISA C (QUOTE ACTIVE))
(OR (GETB C (QUOTE DEFN))
(GETB C (QUOTE INTU))
(GETB C (QUOTE ALGS)))
(ONLY-COMS (GETB C (QUOTE EXS)))
(LIST (LIST [FIX (DOTPROD (LIST (COND ((GETB C (QUOTE EXS))
.9)
(T .76))
.1 .1 .1)
(GETB C (QUOTE WORTH]
(QUOTE FILLIN)
C
(QUOTE EXS]
(MAPCONC PAST (FUNCTION (LAMBDA (PE)
(SETQ GTEMP39 (P-B PE))
(COND
((AND (EQ (P-P PE)
(QUOTE EXS-NOT-BDY))
(EQ (P-OP PE)
(QUOTE FILLIN))
(NULL (GETB GTEMP39 (QUOTE EXS-NOT-BDY)))
(ISA PE (QUOTE ACTIVE)))
(* That is, did we try and fail to fill in
non-exs of GTEMP39)
(SETQ GTEMP36 (LIST (QUOTE FILLIN)
GTEMP39
(QUOTE EXS)))
(SETQ GTEMP37 (SASSOC GTEMP36 PAST))
(* Did we try recently to fill in examples)
(COND
((NULL GTEMP37)
(* No, so let's suggest trying that)
(LIST (CONS (DOTPROD (GETB GTEMP39
(QUOTE WORTH))
(LIST .4 .1))
GTEMP36)))
[(GETB GTEMP39 (QUOTE EXS))
(* Yes, we tried and in fact succeeded)
(* We have tried to fill in non-examples and
examples of the Being, but failed to find
any examples. It is too special.)
[SET-NTH (GETB GTEMP39 (QUOTE WORTH))
1
(AVG2 1 (CAR (GETB GTEMP39
(QUOTE WORTH]
(LIST (LIST (DOTPROD (GETB GTEMP39
(QUOTE WORTH))
(LIST 1.4 .5 .1))
(QUOTE FILLIN)
GTEMP39
(QUOTE GENL]
(T (* Failed on both accounts, so the problem
is just too tough for now.)
NIL]
WORTH (0)
INIT (ANY-OF NIL)
SPEC (COMPOSE-EXS))
(PUTPROPS ANYB GENL (ANYTHING)
WORTH (0)
VIEW (ANY-OF [PROG1 NIL (SETQ GTEMP5 (RIPPLE BA1 (QUOTE GENL]
[AND (FMEMB (QUOTE STRUCTURE)
GTEMP5)
(LIST (APPLYB (QUOTE STRUCTURE-INSERT)
(QUOTE ALGS)
(COPY BA2)
NIL
(CAR (INTERSECTION (SPEC STRUCTURE)
GTEMP5]
(AND (FMEMB (QUOTE ORD-PAIR)
GTEMP5)
(LIST (QUOTE PAIR)
BA2 BA2)))
SPEC (ACTIVE ANYB-ANYP OBJECT))
(PUTPROPS ANYB-ALGS GENL (ANYB-ANYP)
INIT (ANY1OF)
ARGS (BA1 BA2 BA3 BA4 BA5)
CENT (GENL)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-ANAS GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-ANYP GENL (ANYB)
FILLIN1 (APPEND (APPLY (QUOTE UNION)
(APPLYB CS-B (QUOTE ANAS)
CS-P)))
CHECK2 [AND (PROG1 T (ADD-CANDS (LIST (LIST (RMUL CS-INT 1 2)
(QUOTE RESTRUC)
CS-B CS-P]
WORTH (0)
SPEC (ANYB-INST ANYB-ANAS ANYB-CHECK ANYB-CHECK1 ANYB-CHECK2 ANYB-D-R ANYB-DEFN ANYB-DEFN-NOT
ANYB-DOMAIN ANYB-EXS ANYB-EXS-BDY ANYB-EXS-NOT ANYB-EXS-NOT-BDY ANYB-FILLIN
ANYB-FILLIN1 ANYB-FILLIN2 ANYB-GENL ANYB-IN-DOM-OF ANYB-IN-RAN-OF ANYB-INIT
ANYB-INT ANYB-INT-NOT ANYB-INTU ANYB-INV ANYB-RANGE ANYB-RESTRUC ANYB-SPEC
ANYB-SUGG ANYB-UP ANYB-VIEW ANYB-WORTH ANYB-TIES ANYB-ALGS))
(PUTPROPS ANYB-CHECK GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
CENT (GENL)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-CHECK1 GENL (ANYB-ANYP)
ARGS (BA1 BA2 BA3 BA4)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-CHECK2 GENL (ANYB-ANYP)
ARGS (BA1 BA2 BA3 BA4)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-D-R GENL (ANYB-ANYP)
WORTH (0)
INIT (OSET)
SPEC (ACTIVE-D-R)
ARGS (BA1 BA2 BA3)
UNDO-INIT CDR)
(PUTPROPS ANYB-DEFN GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY1OF)
ARGS (BA1 BA2 BA3)
CENT (SPEC)
UNDO-INIT CDR)
(PUTPROPS ANYB-DEFN-NOT GENL (ANYB-ANYP)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3 BA4)
CENT (GENL)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-DOMAIN GENL (ANYB-ANYP)
ARGS (BA1 BA2 BA3 BA4)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-EXS GENL (ANYB-ANYP)
FILLIN1 (APPEND (INSTAN-S (GETB CS-B (QUOTE SPEC))
BA1)
(INSTAN-D (GETB CS-B (QUOTE DEFN))
BA1)
(INSTAN-I (GETB CS-B (QUOTE INTU))
BA1))
FILLIN2 [APPEND (PROG1 NIL (SETB-I CS-B (QUOTE EXS)
(SORT (GETB CS-B (QUOTE EXS))
(QUOTE COUNT)))
(AND ORIG-EMP GEXISTING (PROGN (TAG-DOMAIN)
(TAG-RANGE)))
[ADD-CANDS (LIST (LIST (RMUL CS-INT 3 4)
(QUOTE CHECK)
CS-B
(QUOTE EXS]
(COND ((AND [SOME (DREVERSE (RIPPLE CS-B (QUOTE GENL)))
(FUNCTION
(LAMBDA
(B)
(SETQ INT-THRESH (IPLUS 10 INT-THRESH))
(SETQ
GTEMP9
(SET-DIFFERENCE
(INT-ENUF (GETB B (QUOTE INT))
(QUOTE DEFN))
(CAR (LAST (CAR (GETB CS-B (QUOTE DEFN]
(SETQ ILEV (AVG2 CS-INT 500))
(SETQ NEWB (PACK (LIST (QUOTE INTERESTING-)
CS-B)))
(NOT (IS-CON NEWB)))
(CPRIN1 2 CRLF "Creating new Being, similar to " CS-B ", named "
NEWB ", but restricted so as to make it more interesting."
CRLF)
(BLOWUP-INTERESTING-SPEC BA1 BA2))
(T (SETQ INT-THRESH (AVG2 INT-THRESH INIT-INT-THRESH))
(CPRIN1 9 CRLF
"Thought about creating a restricted interesting version of "
CS-B ", but then I decided not to." CRLF]
SUGG [APPEND [MAPCONC PAST (FUNCTION (LAMBDA (PE)
(COND ((EQ (P-P PE)
(QUOTE EXS))
(LIST (LIST (COND ((NUMBERP (PINT PE))
(RMUL (PINT PE)
1 2))
(T 250))
(QUOTE RE-JUDGE)
(P-B PE)
(QUOTE EXS]
(MAPCONC CONCEPTS (FUNCTION (LAMBDA
(C)
(AND (NULL (GETB C (QUOTE EXS)))
(LIST (LIST [FIX (DOTPROD (LIST .7 .1 .1 .1)
(GETB C (QUOTE WORTH]
(QUOTE FILLIN)
C
(QUOTE EXS]
WORTH (0)
INIT (ANY-OF NIL)
CHECK2 [AND (PROGN [SETB-I CS-B (QUOTE EXS)
(APPLYB (QUOTE SET-STRUC-DIFF)
(QUOTE ALGS)
(APPLYB (QUOTE SET-STRUC-INTERSECT)
(QUOTE ALGS)
(GETB CS-B (QUOTE EXS))
(GETB CS-B (QUOTE EXS)))
(GETB CS-B (QUOTE EXS-BDY]
(SETQ GEXISTING (GETB CS-B (QUOTE EXS]
SPEC (ACTIVE-EXS OBJECT-EXS STRUCTURE-EXS)
ARGS (BA1 BA2 BA3)
CENT (SPEC)
UNDO-INIT CDDR)
(PUTPROPS ANYB-EXS-BDY GENL (ANYB-ANYP)
CHECK1 [AND (PROG1 T (MAPC GEXISTING (FUNCTION (LAMBDA (X1)
(COND
[(FMEMB X1 (LIST NIL (QUOTE ANY1OF)
(QUOTE ANY-OF]
((AND (GETB CS-B (QUOTE DEFN))
(NOT (APPLYB CS-B (QUOTE DEFN)
X1)))
(GTRANSFER X1 (QUOTE NOT-BDY)))
((AND (GETB CS-B (QUOTE INTU))
(NOT (APPLYB CS-B (QUOTE INTU)
X1)))
(GTRANSFER X1 (QUOTE BDY]
SUGG [APPEND (MAPCONC CONCEPTS (FUNCTION
(LAMBDA (C)
(AND (NULL (GETB C (QUOTE EXS-BDY)))
(LIST (LIST [FIX (DOTPROD (LIST .3 .1 .1)
(GETB C (QUOTE WORTH]
(QUOTE FILLIN)
C
(QUOTE EXS-BDY]
WORTH (0)
INIT (ANY-OF NIL)
CHECK2 [AND (SETQ GEXISTING (SETB CS-B (QUOTE EXS-BDY)
(APPEND (GETB (QUOTE ANYB-EXS-BDY)
(QUOTE INIT))
(APPLYB (QUOTE SET-STRUC-INTERSECT)
(QUOTE ALGS)
(GETB CS-B (QUOTE EXS-BDY))
(GETB CS-B (QUOTE EXS-BDY]
SPEC (STRUCTURE-EXS-BDY)
ARGS (BA1 BA2 BA3)
UNDO-INIT CDDR
CENT (SPEC))
(PUTPROPS ANYB-EXS-NOT GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-EXS-NOT-BDY GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
UNDO-INIT CDDR
SPEC (ACTIVE-EXS-NOT-BDY))
(PUTPROPS ANYB-FILLIN GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
CENT (GENL)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-FILLIN1 GENL (ANYB-ANYP)
ARGS (BA1 BA2 BA3 BA4)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-FILLIN2 GENL (ANYB-ANYP)
ARGS (BA1 BA2 BA3 BA4)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-GENL GENL (ANYB-ANYP)
WORTH (0)
ARGS (BA1 BA2 BA3)
CENT (GENL)
UNDO-INIT ACCESS
SPEC (ACTIVE-GENL))
(PUTPROPS ANYB-IN-DOM-OF GENL (ANYB-ANYP)
ARGS (BA1 BA2 BA3 BA4)
CENT (GENL)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-IN-RAN-OF GENL (ANYB-ANYP)
ARGS (BA1 BA2 BA3 BA4)
CENT (GENL)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-INIT GENL (ANYB-ANYP)
ARGS (BA1 BA2 BA3 BA4)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-INT GENL (ANYB-ANYP)
WORTH (0)
INIT (IPLUS (IMATRIX))
ARGS (BA1 BA2 BA3)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-INT-NOT GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-INTU GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-INV GENL (ANYB-ANYP)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3 BA4)
CENT (GENL)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-RANGE GENL (ANYB-ANYP)
ARGS (BA1 BA2 BA3 BA4)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-RESTRUC GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-SPEC GENL (ANYB-ANYP)
WORTH (0)
ARGS (BA1 BA2 BA3)
CENT (SPEC)
UNDO-INIT ACCESS
SPEC (ACTIVE-SPEC))
(PUTPROPS ANYB-SUGG GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-TIES GENL (ANYB-ANYP)
ARGS (BA1 BA2 BA3 BA4)
CENT (GENL)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-UP GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-VIEW GENL (ANYB-ANYP)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3 BA4)
CENT (GENL)
UNDO-INIT ACCESS)
(PUTPROPS ANYB-WORTH GENL (ANYB-ANYP)
WORTH (0)
INIT (ANY-OF NIL)
ARGS (BA1 BA2 BA3)
UNDO-INIT ACCESS)
(PUTPROPS ANYTHING WORTH (0)
DEFN (ANY1OF (TYPE TRIVIAL CONSTANT T))
ALGS (ANY1OF (TYPE TRIVIAL CONSTANT T))
SPEC (ANYB))
(PUTPROPS BAG-STRUC GENL (UNORD-OBJ MULT-STRUC)
WORTH (300 200 700 500 400 990 900 1000 800 800 1000)
DEFN [ANY1OF (TYPE NONRECURSIVE (MATCH BA1 WITH ('BAG $)))
(TYPE RECURSIVE (COND [(EQUAL BA1 (LIST (QUOTE BAG]
((NOT (AND (LISTP BA1)
(CDR BA1)))
NIL)
((APPLYB (QUOTE BAG-STRUC)
(QUOTE DEFN)
(APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
(APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL
(COPY BA1))
(COPY BA1]
INTU [ANY1OF (CONS (QUOTE BAG)
(RAND-SUBSET USERNAMES))
(CONS (QUOTE BAG)
(APPEND (SETQ RB1 (RAND-SUBSET USERNAMES))
(RAND-SUBSET RB1)))
(CONS (QUOTE BAG)
(RAND-PERMUTE (RAND-SUBSET USERNAMES]
DEFN-NOT [ANY-OF (TYPE NONRECURSIVE (NEQ (CAR BA1)
(QUOTE BAG]
IN-DOM-OF (BAG-STRUC-INSERT))
(PUTPROPS BAG-STRUC-DELETE GENL (STRUCTURE-DELETE)
WORTH (0)
ALGS [ANY1OF [TYPE NONRECURSIVE (AND (SETQ GTEMP7 (FMEMB BA1 (CDR BA2)))
(COND ((CDR GTEMP7)
(RPLACA GTEMP7 (APPEND (CADR GTEMP7)))
(RPLACD GTEMP7 (CDDR GTEMP7)))
((RPLACD BA2 (DREMOVE BA1 (CDR BA2]
(TYPE RECURSIVE (COND ((NULL (CADR BA2))
BA2)
(T (SETQ BA3 (CADR BA2))
(RPLACD BA2 (CDDR BA2))
(COND ((APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
BA1 BA3)
BA2)
(T (APPLYB (QUOTE BAG-STRUC-INSERT)
(QUOTE ALGS)
BA3
(APPLYB (QUOTE BAG-STRUC-DELETE)
(QUOTE ALGS)
BA1 BA2]
UP (BAG-STRUC-IN-DOM-OF)
INV (TYPE NONRECURSIVE TRANSFORM (APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE INV)
BA1 BA2 (QUOTE BAG-STRUC)))
D-R (OSET (ANYTHING BAG-STRUC BAG-STRUC)))
(PUTPROPS BAG-STRUC-INSERT GENL (STRUCTURE-INSERT)
WORTH (0)
ALGS [ANY1OF
(TYPE NONRECURSIVE OPAQUE QUICK
(AND (OR BA2 [CAR (SETQ BA2 (LIST (CAAR (LAST (OR (GETB (QUOTE BAG-STRUC)
(QUOTE EXS))
GEXISTING]
(BOOST (QUOTE FILLIN)
(QUOTE BAG-STRUC)
(QUOTE EXS)))
(OR BA1 (SETQ BA1 (RAND-THING)))
(ATTACH (CAR BA2)
(MERGE (LIST BA1)
(CDR BA2)
(QUOTE SORD]
UP (BAG-STRUC-IN-DOM-OF)
D-R (OSET (ANYTHING BAG-STRUC BAG-STRUC)))
(PUTPROPS BAG-STRUC-INTERSECT GENL (STRUCTURE-INTERSECT)
WORTH (0)
ALGS (ANY1OF [TYPE NONRECURSIVE (ANY1OF [SUBSET BA1 (FUNCTION
(LAMBDA (Z)
(AND (APPLYB (QUOTE
STRUCTURE-MEMB)
(QUOTE ALGS)
Z BA2)
(APPLYB (QUOTE
BAG-STRUC-DELETE)
(QUOTE ALGS)
Z BA2]
(SUBSET BA2 (FUNCTION
(LAMBDA (Z)
(AND (APPLYB (QUOTE
STRUCTURE-MEMB)
(QUOTE ALGS)
Z BA1)
(APPLYB (QUOTE
BAG-STRUC-DELETE)
(QUOTE ALGS)
Z BA1]
(TYPE RECURSIVE (* This only works when using the slow defn of
STRUCTURE-MEMB, when a NIL as its first arg. means to
FIND such a member, not just test it. Perhaps we should
have a more active new B. for just that purpose.)
(PROGN [COND ((SETQ BA4 (APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL BA2))
(SETQ BA3 (APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
BA4 BA1))
(SETQ BA1 (APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
BA4 BA1))
(SETQ BA2 (APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
BA4 BA2))
(SETQ BA1 (APPLYB (QUOTE BAG-STRUC-INTERSECT)
(QUOTE ALGS)
BA1 BA2))
(AND BA3 (APPLYB (QUOTE BAG-STRUC-INSERT)
BA4 BA1]
BA1)))
UP (BAG-STRUC-IN-DOM-OF)
D-R (OSET (BAG-STRUC BAG-STRUC BAG-STRUC)))
(PUTPROPS COALESCE GENL (OPERATION)
WORTH (250 150 650 500 400 990 900 1000 800 800 1000)
D-R (OSET (OPERATION OPERATION)
(RELATION RELATION)
(PREDICATE PREDICATE)
(ACTIVE ACTIVE))
DEFN [ANY1OF (TYPE NONRECURSIVE (AND (ISA BA1 (QUOTE ACTIVE))
(ISA BA2 (QUOTE ACTIVE))
(ARE-EQUIV BA2 (APPLYB (QUOTE COALESCE)
(QUOTE ALGS)
BA1]
ALGS [ANY1OF (TYPE NONRECURSIVE NEWB (AND (IGREATERP [LENGTH (CAR (GETB BA1 (QUOTE D-R]
2)
(SETQ GTEMP210 (GLUE (QUOTE COALESCED)
BA1))
[OR (SETQ GSWI NIL)
(NOT (IS-CON GTEMP210))
(SETQ GTEMP210 (PROG ((I 1))
L1
(COND ((IS-CON (SETQ
GTEMP11
(GLUE GTEMP210
I)))
(SETQ I (ADD1 I))
(GO L1))
((RETURN GTEMP11]
(BLOWUP-COALES BA1 GTEMP210]
UP (OPERATION)
SUGG [APPEND (MAPCONC CONCEPTS (FUNCTION (LAMBDA
(C)
(AND (IGREATERP (DOTPROD (GETB C (QUOTE WORTH))
(LIST .1 .2 .1))
DO-THRESH)
(ISA C (QUOTE ACTIVE))
(IGREATERP [LENGTH (CAR (GETB C (QUOTE D-R]
2)
[OR (ILESSP DO-THRESH 66)
(NOT (IS-CON (GLUE (QUOTE COALESCED)
C]
(LIST (LIST [FIX (DOTPROD (LIST .7 .1 .1 .1)
(GETB C (QUOTE WORTH]
(QUOTE APPLYB)
(Q COALESCE)
(Q ALGS)
(KWOTE C])
(PUTPROPS COMPOSE GENL (OPERATION)
WORTH (376 150 700 500 400 990 900 1000 800 800 1000)
D-R (OSET (OPERATION OPERATION OPERATION)
(RELATION RELATION RELATION)
(PREDICATE ACTIVE PREDICATE)
(ACTIVE ACTIVE ACTIVE))
DEFN [ANY1OF [TYPE NONRECURSIVE (AND (ISA BA1 (QUOTE ACTIVE))
(ISA BA2 (QUOTE ACTIVE))
(ISA BA3 (QUOTE ACTIVE))
(ARE-EQUIV BA3 (APPLYB (QUOTE COMPOSE)
(QUOTE ALGS)
BA1 BA2]
(TYPE PC (FOREACH X IN (DOMAIN BA2)
RETURN
(BA1 (BA2 X]
ALGS [ANY1OF (TYPE QUASIRECURSIVE CASES
(PROGN [COND ((NULL BA1)
(APPLYB (QUOTE COMPOSE)
(QUOTE ALGS)
(RAND-MEMB (ACEX ACTIVE))
BA2 BA3 BA4))
((NULL BA2)
(APPLYB (QUOTE COMPOSE)
(QUOTE ALGS)
BA1
(RAND-MEMB (ACEX ACTIVE))
BA3 BA4))
[(IS-CON (SETQ GTEMP12 (GLUEC BA1 BA2]
([AND [SETQ GTEMP9 (LIST (QUOTE EQUAL)
(QUOTE BA3)
(LIST (QUOTE APPLYB)
(Q COMPOSE)
(Q ALGS)
(KWOTE BA1)
(KWOTE BA2)
(QUOTE BA1)
(QUOTE BA2]
(SETQ GTEMP11 (SOME (ACEX COMPOSE)
(FUNCTION (LAMBDA
(Z)
(MEMBER GTEMP9
(GETB (EXA Z)
(QUOTE DEFN]
(SETQ GTEMP12 (EXA GTEMP11)))
((AND BA1 BA2 (GETHASH BA1 HCON)
(GETHASH BA2 HCON)
(ISA BA1 (QUOTE ACTIVE))
(ISA BA2 (QUOTE ACTIVE)))
(CREATEB GTEMP12)
(SETQ GTEMP11 (CON-MERGE-ARGS BA1 BA2 GTEMP12))
[INCRB GTEMP12 (QUOTE DEFN)
(LIST (QUOTE TYPE)
(QUOTE APPLICATION)
(QUOTE OF)
(QUOTE COMPOSE)
(APPEND (LIST (QUOTE APPLYB)
(Q COMPOSE)
(Q ALGS)
(KWOTE BA1)
(KWOTE BA2))
(FIRSTN (LENGTH (CAAR GTEMP11))
BA-LIST]
(SETB GTEMP12 (QUOTE UP)
(LIST (QUOTE COMPOSE)))
(INCRB (QUOTE COMPOSE)
(QUOTE EXS)
GTEMP12)
(SETB GTEMP12 (QUOTE D-R)
(CAR GTEMP11))
[SETB GTEMP12 (QUOTE ALGS)
(LIST (QUOTE ANY1OF)
(LIST (QUOTE TYPE)
(QUOTE NONRECURSIVE)
(QUOTE APPLICATION)
(QUOTE OF)
(QUOTE COMPOSE)
(CADR GTEMP11]
(SETB GTEMP12 (QUOTE WORTH)
(LIST (DOTPROD (LIST (CAR (GETB BA1 (QUOTE WORTH)))
(CAR (GETB BA2 (QUOTE WORTH)))
DO-THRESH GCNT CS-INT)
(LIST .4 .3 .2 .5 .2))
(AVG2 DO-THRESH CS-INT)
GCNT 10]
(COND ((AND (OR BA3 BA4 BA5)
(IS-CON GTEMP12))
(APPLYB GTEMP12 (QUOTE ALGS)
BA3 BA4 BA5))
(T GTEMP12]
UP (OPERATION)
INT [IPLUS (IMATRIX (1 2 3)
(4 5))
(COND [(INTERSECTION (MAPAPPEND (GETB BA2 (QUOTE D-R))
(QUOTE LAST))
(MAPAPPEND (GETB BA1 (QUOTE D-R))
(QUOTE ALL-BUT-LAST)))
300
(IDIFF 400 (ITIMES 100 (IPLUS (LENGTH (GETB BA1 (QUOTE D-R)))
(LENGTH (GETB BA2 (QUOTE D-R]
(NIL (* In some interpretation, RAN2 is 1 comp of DOM1)))
(COND [[MEMB [CAR (LAST (CAR (GETB BA2 (QUOTE D-R]
(ALL-BUT-LAST (CAR (GETB BA1 (QUOTE D-R]
400
(IDIFF 1000 (ITIMES 100 (LENGTH (CAR (GETB BA1 (QUOTE D-R]
(NIL (* In canon interp, RAN2 is comp of DOM1)))
(COND [[IS-ONE-OF [CAR (LAST (CAR (GETB BA2 (QUOTE D-R]
(ALL-BUT-LAST (CAR (GETB BA1 (QUOTE D-R]
350
(IDIFF [ITIMES 100
(IDIFF [LENGTH (CAR (GETB BA1 (QUOTE D-R]
(LENGTH (RIPPLE [IS-ONE-OF
[SETQ TMP4
(CAR (LAST (GETB BA2 (QUOTE D-R]
(ALL-BUT-LAST (CAR (GETB BA1
(QUOTE D-R]
(QUOTE GENL]
(ITIMES 50 (LENGTH (RIPPLE TMP4 (QUOTE GENL]
(NIL (* In canon interp, RAN2 ISA comp of DOM1)))
(COND [[MEMB [CAR (LAST (CAR (GETB BA1 (QUOTE D-R]
(ALL-BUT-LAST (CAR (GETB BA2 (QUOTE D-R]
450
(IPLUS 300 (COND ([MEMB [CAR (LAST (CAR (GETB BA1 (QUOTE D-R]
(ALL-BUT-LAST (CAR (GETB BA1 (QUOTE D-R]
10)
(T 250))
(COND ([MEMB [CAR (LAST (CAR (GETB BA2 (QUOTE D-R]
(ALL-BUT-LAST (CAR (GETB BA2 (QUOTE D-R]
11)
(T 250))
(ITIMES 70 (LENGTH (RIPPLE [CAR (LAST (CAR (GETB BA1 (QUOTE D-R]
(QUOTE GENL]
(NIL (* RAN1 is 1 comp of DOM2)))
(COND [[ISA [CAR (LAST (CAR (GETB BA1 (QUOTE D-R]
(ALL-BUT-LAST (CAR (GETB BA2 (QUOTE D-R]
250
(IPLUS 50 (COND ([ISA [CAR (LAST (CAR (GETB BA1 (QUOTE D-R]
(ALL-BUT-LAST (CAR (GETB BA1 (QUOTE D-R]
10)
(T 100))
(COND ([ISA [CAR (LAST (CAR (GETB BA2 (QUOTE D-R]
(ALL-BUT-LAST (CAR (GETB BA2 (QUOTE D-R]
11)
(T 100))
(ITIMES 50 (LENGTH (RIPPLE [CAR (LAST (CAR (GETB BA1 (QUOTE D-R]
(QUOTE GENL]
(NIL (* RAN1 related by ISA to DOM2])
(PUTPROPS COMPOSE-D-R GENL (ACTIVE-D-R)
WORTH (0)
FILLIN1 [APPEND (PROGN (ARGS-ASA COMPOSE F1 F2)
(CADAR (CON-MERGE-ARGS F1 F2])
(PUTPROPS COMPOSE-EXS GENL (ACTIVE-EXS)
WORTH (100 75 100 100 50)
FILLIN (ANY-OF (OR BA1 BA2 (ALGS CS-B))))
(PUTPROPS COMPOSE-EXS-D-R GENL (ACTIVE-D-R)
WORTH (0)
FILLIN1 (APPEND (PROGN (ARGS-ASA COMPOSE F1 F2)
[SETQ RAN1 (LAST (CAR (GETB F1 (QUOTE D-R]
(SETQ DOM1 (LDIFF (CAR (GETB F1 (QUOTE D-R)))
RAN1))
[SETQ RAN2 (LAST (CAR (GETB F2 (QUOTE D-R]
(SETQ DOM2 (LDIFF (CAR (GETB F2 (QUOTE D-R)))
RAN2))
[SETQ DOM3 (AND (CDR DOM1)
(LIST (CADR (MIN2 (APPEND RAN2 RAN2 RAN2 RAN2)
DOM1
(QUOTE FRAC-INCLU]
(APPEND DOM2 DOM3 RAN1))))
(PUTPROPS CONSTRUCTIVE GENL (PREDICATE)
WORTH (0)
DEFN [ANY1OF (TYPE QUASIRECURSIVE (OR (FMEMB BA1 CONSTRUCTIVE-OPS)
(RIPPLE-UNTIL BA1 (QUOTE GENL)
(LIST (QUOTE FMEMB)
(QUOTE B)
(QUOTE CONSTRUCTIVE-OPS])
(PUTPROPS EMPTY GENL (PREDICATE)
WORTH (376 150 700 500 400 990 900 1000 800 800 1000)
ALGS [ANY1OF (TYPE NONRECURSIVE OPAQUE (NULL (CDR BA1)))
(TYPE NONRECURSIVE (AND (APPLYB (QUOTE STRUCTURE)
(QUOTE DEFN)
BA1)
(APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL BA1]
D-R (OSET (STRUCTURE TRUTH-VAL))
DEFN [ANY1OF (TYPE NONRECURSIVE (NOT (APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL BA1)))
(TYPE PC (FOREACH S (IFF (EMPTY S)
(FOREACH X (NOT (STRUCTURE-MEMB X S])
(PUTPROPS EMPTY-STRUC GENL (STRUCTURE)
WORTH (376 150 700 500 400 990 900 1000 800 800 1000)
DEFN [ANY1OF (TYPE NONRECURSIVE (AND (ISA BA1 (QUOTE STRUCTURE))
(NULL (CDR BA1])
(PUTPROPS FINAL WORTH (0)
ALGS [ANY1OF (TYPE NONRECURSIVE (COND ((AND BA2 (CDR BA1))
(FRPLACA (LAST BA1)
BA2))
(T (CAR (LAST (CDR BA1]
UP (BAG-STRUC-IN-DOM-OF OPERATION)
DEFN [ANY-OF (TYPE QUASIRECURSIVE (EQUAL BA2 (APPLYB (QUOTE FINAL)
(QUOTE ALGS)
BA1]
GENL (OPERATION)
D-R (OSET (ORD-OBJ ANYTHING)))
(PUTPROPS FIRST WORTH (0)
ALGS [ANY1OF (TYPE NONRECURSIVE (COND (BA2 (FSET-NTH BA1 2 BA2))
(T (CADR BA1]
UP (BAG-STRUC-IN-DOM-OF OPERATION)
DEFN [ANY-OF (TYPE QUASIRECURSIVE (EQUAL BA2 (APPLYB (QUOTE FIRST)
(QUOTE ALGS)
BA1]
GENL (OPERATION)
D-R (OSET (ORD-OBJ ANYTHING)))
(PUTPROPS LIST-STRUC GENL (ORD-OBJ MULT-STRUC)
WORTH (300 200 700 500 400 990 900 1000 800 800 1000)
DEFN [ANY1OF (TYPE NONRECURSIVE (MATCH BA1 WITH ('VECTOR $)))
(TYPE RECURSIVE (COND [(EQUAL BA1 (LIST (QUOTE VECTOR]
((NOT (AND (LISTP BA1)
(CDR BA1)))
NIL)
((APPLYB (QUOTE LIST-STRUC)
(QUOTE DEFN)
(APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
(APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL
(COPY BA1))
(COPY BA1]
INTU [ANY1OF (CONS (QUOTE VECTOR)
(RAND-SUBSET USERNAMES))
(CONS (QUOTE VECTOR)
(APPEND (SETQ RB1 (RAND-SUBSET USERNAMES))
(RAND-SUBSET RB1)))
(CONS (QUOTE VECTOR)
(RAND-PERMUTE (RAND-SUBSET USERNAMES]
IN-DOM-OF (LIST-STRUC-INSERT FIRST REAR FINAL)
EXS (ANY-OF NIL (VECTOR (VECTOR))
(VECTOR (CLASS DOUG))
(VECTOR DOUG ED BRUCE)
(VECTOR DOUG)
(VECTOR ED)
(VECTOR DOUG ED)
(VECTOR ED DOUG)
(VECTOR DOUG DOUG)
(VECTOR ED ED)
(VECTOR DOUG ED ED)
(VECTOR DOUG ED DOUG)
(VECTOR DOUG DOUG ED)
(VECTOR ED ED ED)
(VECTOR DOUG DOUG DOUG)
(VECTOR ED ED DOUG)
(VECTOR ED DOUG ED)
(VECTOR ED DOUG DOUG))
EXS-BDY (ANY-OF NIL (VECTOR))
DEFN-NOT [ANY-OF (TYPE NONRECURSIVE (NEQ (CAR BA1)
(QUOTE VECTOR]
VIEW (ANY-OF NIL))
(PUTPROPS LIST-STRUC-DELETE GENL (STRUCTURE-DELETE)
WORTH (0)
ALGS [ANY1OF (TYPE RECURSIVE (COND ((NULL (CADR BA2))
BA2)
(T (SETQ BA3 (CADR BA2))
(RPLACD BA2 (CDDR BA2))
(COND ((APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
BA1 BA3)
BA2)
(T (APPLYB (QUOTE STRUCTURE-INSERT)
(QUOTE ALGS)
BA3
(APPLYB (QUOTE LIST-STRUC-DELETE)
(QUOTE ALGS)
BA1 BA2]
UP (LIST-STRUC-IN-DOM-OF)
INV (TYPE NONRECURSIVE TRANSFORM (APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE INV)
BA1 BA2 (QUOTE LIST-STRUC)))
D-R (OSET (ANYTHING LIST-STRUC LIST-STRUC)))
(PUTPROPS LIST-STRUC-INSERT GENL (STRUCTURE-INSERT)
WORTH (0)
ALGS [ANY1OF
(TYPE NONRECURSIVE OPAQUE QUICK
(AND (OR BA2 [CAR (SETQ BA2 (LIST (CAAR (LAST (OR (GETB (QUOTE LIST-STRUC)
(QUOTE EXS))
GEXISTING]
(BOOST (QUOTE FILLIN)
(QUOTE LIST-STRUC)
(QUOTE EXS)))
(OR BA1 (SETQ BA1 (RAND-THING)))
(ATTACH (CAR BA2)
(FRPLACA BA2 BA1]
UP (LIST-STRUC-IN-DOM-OF)
D-R (OSET (ANYTHING LIST-STRUC LIST-STRUC)))
(PUTPROPS LIST-STRUC-INTERSECT GENL (STRUCTURE-INTERSECT)
WORTH (0)
ALGS [ANY1OF (TYPE RECURSIVE (MAPCONC BA1 (FUNCTION (LAMBDA (Z)
(COND
((MEMBER Z BA2)
(SETQ
BA2
(CDR (MEMBER Z BA2)))
(LIST Z]
UP (LIST-STRUC-IN-DOM-OF)
D-R (OSET (LIST-STRUC LIST-STRUC LIST-STRUC)))
(PUTPROPS MULT-STRUC GENL (STRUCTURE)
SPEC (LIST-STRUC BAG-STRUC)
WORTH (0))
(PUTPROPS NON-EMPTY GENL (PREDICATE)
WORTH (376 150 700 500 400 990 900 1000 800 800 1000)
ALGS [ANY1OF (TYPE NONRECURSIVE OPAQUE (CDR BA1))
(TYPE NONRECURSIVE (AND (APPLYB (QUOTE STRUCTURE)
(QUOTE DEFN)
BA1)
(NOT (APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL BA1]
D-R (OSET (STRUCTURE TRUTH-VAL))
DEFN [ANY1OF (TYPE NONRECURSIVE (APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL BA1))
(TYPE PC (FOREACH S (IFF (NON-EMPTY S)
(FOREACH X (STRUCTURE-MEMB X S])
(PUTPROPS NONMULT-STRUC SPEC (SET-STRUC OSET-STRUC)
WORTH (0)
GENL (STRUCTURE))
(PUTPROPS OBJ-EQUAL GENL (PREDICATE OPERATION)
WORTH (700 500 666 4)
ALGS [ANY1OF (TYPE NONRECURSIVE OPAQUE (EQUAL BA1 BA2))
[TYPE RECURSIVE MALLABLE (COND ((OR (NLISTP X)
(NLISTP Y))
(EQ X Y))
(T (AND (APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
(CAR X)
(CAR Y))
(APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
(CDR X)
(CDR Y]
(TYPE RECURSIVE SLOW (COND ((AND (NLISTP (CDR BA1))
(NLISTP (CDR BA2)))
(EQ (CAR BA1)
(CAR BA2)))
((OR (NLISTP (CDR BA1))
(NLISTP (CDR BA2)))
NIL)
(T (AND (APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
(APPLYB (QUOTE FIRST)
(QUOTE ALGS)
BA1)
(APPLYB (QUOTE FIRST)
(QUOTE ALGS)
BA2))
(APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
(APPLYB (QUOTE REAR)
(QUOTE ALGS)
BA1)
(APPLYB (QUOTE REAR)
(QUOTE ALGS)
BA2]
UP (PREDICATE OBJECT-IN-DOM-OF)
SPEC (OSET-STRUC-EQUAL LIST-STRUC-EQUAL STRUCTURE-EQUAL)
D-R (OSET (OBJECT OBJECT TRUTH-VAL)))
(PUTPROPS OBJECT GENL (ANYB)
SPEC (STRUCTURE ORD-PAIR ORD-OBJ TRUTH-VAL UNORD-OBJ)
WORTH (0))
(PUTPROPS OBJECT-EXS GENL (ANYB-EXS)
WORTH (0)
SPEC (ORD-OBJ-EXS UNORD-OBJ-EXS)
CHECK1 [AND (PROG1 T (MAPC GEXISTING (FUNCTION (LAMBDA (X1)
(COND ((AND (GETB CS-B (QUOTE DEFN))
(NOT (APPLYB CS-B
(QUOTE DEFN)
X1)))
(GTRANSFER X1 (QUOTE NOT-BDY)))
((AND (GETB CS-B (QUOTE INTU))
(NOT (APPLYB CS-B
(QUOTE INTU)
X1)))
(GTRANSFER X1 (QUOTE BDY])
(PUTPROPS OPERATION GENL (ACTIVE)
WORTH (0)
SPEC (COMPOSE FINAL FIRST OBJ-EQUAL REAR STRUCTURE-DELETE STRUCTURE-DIFF STRUCTURE-INSERT
STRUCTURE-INTERSECT STRUCTURE-MEMB REV-ORD-PAIR COALESCE)
EXS (ANY-OF NIL REAR STRUCTURE-DELETE STRUCTURE-DIFF STRUCTURE-INSERT STRUCTURE-INTERSECT
STRUCTURE-MEMB))
(PUTPROPS ORD-OBJ GENL (OBJECT)
SPEC (OSET-STRUC LIST-STRUC ORD-PAIR)
WORTH (0))
(PUTPROPS ORD-OBJ-EXS GENL (OBJECT-EXS)
WORTH (0)
CHECK1 [AND (GETHASH [SETQ GTEMP4 (PACK (LIST CS-B (QUOTE -INSERT]
HCON)
(SETQ GEXISTING (SETB CS-B (QUOTE EXS)
(APPEND (GETB (QUOTE ANYB-EXS)
(QUOTE INIT))
[MAPCAR (GETB CS-B (QUOTE EXS))
(FUNCTION (LAMBDA (Z)
(CONS (CAR Z)
(RAND-PERMUTE
(CDR Z]
(GETB CS-B (QUOTE EXS])
(PUTPROPS ORD-PAIR GENL (OBJECT ORD-OBJ)
IN-DOM-OF (REV-ORD-PAIR FIRST FINAL)
WORTH (75 200 700 500 400 990 900 1000 800 800 (COND ((GETB INTERESTING-ORD-PAIR (QUOTE EXS))
801)))
DEFN [ANY1OF (TYPE NONRECURSIVE (MATCH BA1 WITH ('PAIR & &]
VIEW [ANY-OF [PROG1 NIL (SETQ GTEMP5 (RIPPLE BA1 (QUOTE GENL]
(AND (FMEMB (QUOTE STRUCTURE)
GTEMP5)
(LIST (CAR (INTERSECTION (SPEC STRUCTURE)
GTEMP5))
(APPLYB (QUOTE FIRST)
(QUOTE ALGS)
BA2)
(APPLYB (QUOTE FINAL)
(QUOTE ALGS)
BA2]
INTU (ANY1OF (LIST (QUOTE PAIR)
(RAND-MEMB USERNAMES)
(RAND-MEMB USERNAMES))
(LIST (QUOTE PAIR)
(RAND-THING)
(RAND-THING))
(LIST (QUOTE PAIR)
(SETQ RB1 (RAND-THING))
RB1))
DEFN-NOT [ANY-OF (TYPE NONRECURSIVE (NLISTP BA1))
(TYPE NONRECURSIVE (NEQ (CAR BA1)
(QUOTE PAIR])
(PUTPROPS OSET-STRUC GENL (ORD-OBJ NONMULT-STRUC)
WORTH (300 200 700 500 400 990 900 1000 800 800 1000)
DEFN [ANY1OF (TYPE NONRECURSIVE (MATCH BA1 WITH ('OSET $)))
(TYPE RECURSIVE (COND [(EQUAL BA1 (LIST (QUOTE OSET]
((NOT (AND (LISTP BA1)
(CDR BA1)))
NIL)
((APPLYB (QUOTE OSET-STRUC)
(QUOTE DEFN)
(APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
(APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL
(COPY BA1))
(COPY BA1]
INTU [ANY1OF (CONS (QUOTE OSET)
(RAND-SUBSET USERNAMES))
(CONS (QUOTE OSET)
(RAND-PERMUTE (RAND-SUBSET USERNAMES]
IN-DOM-OF (OSET-STRUC-INSERT FIRST REAR FINAL)
DEFN-NOT [ANY-OF (TYPE NONRECURSIVE (NEQ (CAR BA1)
(QUOTE OSET])
(PUTPROPS OSET-STRUC-DELETE GENL (STRUCTURE-DELETE)
WORTH (0)
ALGS [ANY1OF (TYPE RECURSIVE (COND ((NULL (CDR BA2))
BA2)
(T (SETQ BA4 (CADR BA2))
(RPLACD BA2 (CDDR BA2))
(SETQ BA2 (APPLYB (QUOTE OSET-STRUC-DELETE)
(QUOTE ALGS)
BA1 BA2))
(COND ((APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
BA1 BA4)
BA2)
(T (APPLYB (QUOTE STRUCTURE-INSERT)
(QUOTE ALGS)
BA4 BA2]
UP (OSET-STRUC-IN-DOM-OF)
INV (TYPE NONRECURSIVE TRANSFORM (APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE INV)
BA1 BA2 (QUOTE OSET-STRUC)))
D-R (OSET (ANYTHING OSET-STRUC OSET-STRUC)))
(PUTPROPS OSET-STRUC-INSERT GENL (STRUCTURE-INSERT)
WORTH (0)
ALGS (ANY1OF
(TYPE NONRECURSIVE OPAQUE QUICK
(AND (OR BA2 [CAR (SETQ BA2 (LIST (CAAR (LAST (OR (GETB (QUOTE OSET-STRUC)
(QUOTE EXS))
GEXISTING]
(BOOST (QUOTE FILLIN)
(QUOTE OSET-STRUC)
(QUOTE EXS)))
(OR BA1 (NOT (MEMBER (SETQ BA1 (RAND-THING))
BA2))
(SETQ BA1 (COPY BA2)))
(OR (MEMBER BA1 (CDR BA2))
(ATTACH (CAR BA2)
(FRPLACA BA2 BA1)))
BA2)))
UP (OSET-STRUC-IN-DOM-OF)
D-R (OSET (ANYTHING OSET-STRUC OSET-STRUC)))
(PUTPROPS OSET-STRUC-INTERSECT GENL (STRUCTURE-INTERSECT)
WORTH (0)
ALGS [ANY1OF (TYPE RECURSIVE (MAPCONC BA1 (FUNCTION (LAMBDA (Z)
(COND
((MEMBER Z BA2)
(SETQ
BA2
(CDR (MEMBER Z BA2)))
(LIST Z]
UP (OSET-STRUC-IN-DOM-OF)
D-R (OSET (OSET-STRUC OSET-STRUC OSET-STRUC)))
(PUTPROPS PREDICATE GENL (ACTIVE)
WORTH (0)
D-R (OSET (ANYTHING TRUTH-VAL))
SPEC (CONSTRUCTIVE NON-EMPTY EMPTY OBJ-EQUAL)
EXS (ANY-OF NIL STRUCTURE-EQUAL))
(PUTPROPS REAR WORTH (0)
ALGS [ANY1OF (TYPE NONRECURSIVE (COND [BA2 (CONS (CAR BA1)
(CONS (CADR BA1)
(CDR BA2]
(T (CONS (CAR BA1)
(CDDR BA1]
UP (STRUCTURE-IN-DOM-OF OPERATION)
DEFN (ANY-OF (TYPE QUASIRECURSIVE (APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
(APPLYB (QUOTE REAR)
(QUOTE ALGS)
BA1)
BA2)))
GENL (OPERATION)
D-R (OSET (ORD-OBJ ORD-OBJ))
IN-DOM-OF (COMPOSE))
(PUTPROPS RELATION GENL (ACTIVE)
WORTH (0))
(PUTPROPS REV-ORD-PAIR GENL (OPERATION)
WORTH (300 200 775)
ALGS [ANY1OF [TYPE NONRECURSIVE OPAQUE (RPLACD BA1 (DREVERSE (CDR BA1]
(TYPE NONRECURSIVE (LIST (QUOTE PAIR)
(APPLYB (QUOTE FIRST)
(QUOTE ALGS)
BA1)
(APPLYB (QUOTE FINAL)
(QUOTE ALGS)
BA1]
UP (ORD-PAIR-IN-DOM-OF)
D-R (OSET (ORD-PAIR ORD-PAIR)))
(PUTPROPS SET-STRUC GENL (UNORD-OBJ NONMULT-STRUC)
WORTH (800 800 700 500 400 990 900 1000 800 800 1000)
DEFN [ANY1OF (TYPE NONRECURSIVE (MATCH BA1 WITH ('CLASS $)))
(TYPE RECURSIVE (COND [(EQUAL BA1 (LIST (QUOTE CLASS]
((NOT (AND (LISTP BA1)
(CDR BA1)))
NIL)
((APPLYB (QUOTE SET-STRUC)
(QUOTE DEFN)
(APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
(APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL
(COPY BA1))
(COPY BA1]
INTU [ANY1OF (CONS (QUOTE CLASS)
(RAND-SUBSET USERNAMES))
(CONS (QUOTE CLASS)
(RECTANGLE (RAND 0 7)
(RAND 0 7)
(RAND 0 7)
(RAND 0 7]
IN-DOM-OF (SET-STRUC-INSERT)
DEFN-NOT [ANY-OF (TYPE NONRECURSIVE (NEQ (CAR BA1)
(QUOTE CLASS]
VIEW (ANY-OF NIL)
SPEC NIL)
(PUTPROPS SET-STRUC-DELETE GENL (STRUCTURE-DELETE)
WORTH (0)
ALGS [ANY1OF [TYPE NONRECURSIVE QUICK (COND ((AND BA1 BA2)
(DREMOVE BA1 BA2))
(BA1 (LIST (QUOTE CLASS)))
(BA2 (RPLACD BA2 (CDDR BA2]
(TYPE RECURSIVE (COND ((NULL (CDR BA2))
BA2)
(T (SETQ BA4 (CADR BA2))
(RPLACD BA2 (CDDR BA2))
(SETQ BA2 (APPLYB (QUOTE SET-STRUC-DELETE)
(QUOTE ALGS)
BA1 BA2))
(COND ((APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
BA1 BA4)
BA2)
(T (APPLYB (QUOTE STRUCTURE-INSERT)
(QUOTE ALGS)
BA4 BA2]
UP (SET-STRUC-IN-DOM-OF)
INV (TYPE NONRECURSIVE TRANSFORM (APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE INV)
BA1 BA2 (QUOTE SET-STRUC)))
D-R (OSET (ANYTHING SET-STRUC SET-STRUC))
DEFN [ANY1OF (TYPE PC (FOREACH X Y S (IFF (STRUCTURE-MEMB Y (SET-STRUC-DELETE X S))
(AND (STRUCTURE-MEMB Y S)
(NOT (OBJ-EQUAL X Y])
(PUTPROPS SET-STRUC-DIFF GENL (STRUCTURE-DIFF)
WORTH (0)
ALGS (ANY1OF (TYPE NONRECURSIVE QUICK OPAQUE (PROGN [MAPC BA2 (FUNCTION (LAMBDA
(Z)
(SETQ
BA1
(REMOVE Z BA1]
BA1))
[TYPE NONRECURSIVE (SUBSET BA1 (FUNCTION (LAMBDA (Z)
(NOT (APPLYB (QUOTE
STRUCTURE-MEMB)
(QUOTE ALGS)
Z BA2]
(TYPE RECURSIVE (PROGN [COND ((SETQ BA4 (APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL BA2))
(SETQ BA1 (APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
BA4 BA1))
(SETQ BA1 (APPLYB (QUOTE SET-INTERSECT'ALGS)
BA1 BA2))
(AND (NOT (APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
BA4 BA2))
(APPLYB (QUOTE SET-STRUC-INSERT)
BA4 BA1]
BA1)))
UP (SET-STRUC-IN-DOM-OF)
D-R (OSET (SET-STRUC SET-STRUC SET-STRUC)))
(PUTPROPS SET-STRUC-INSERT GENL (STRUCTURE-INSERT)
WORTH (0)
ALGS (ANY1OF
(TYPE NONRECURSIVE OPAQUE QUICK
(AND (OR BA2 [CAR (SETQ BA2 (LIST (CAAR (LAST (OR (GETB (QUOTE SET-STRUC)
(QUOTE EXS))
GEXISTING]
(BOOST (QUOTE FILLIN)
(QUOTE SET-STRUC)
(QUOTE EXS)))
(OR BA1 (NOT (MEMBER (SETQ BA1 (RAND-THING))
BA2))
(SETQ BA1 (COPY BA2)))
[OR (MEMBER BA1 (CDR BA2))
(RPLACD BA2 (MERGE (LIST BA1)
(CDR BA2)
(QUOTE SORD]
BA2)))
UP (SET-STRUC-IN-DOM-OF)
D-R (OSET (ANYTHING SET-STRUC SET-STRUC)))
(PUTPROPS SET-STRUC-INTERSECT GENL (STRUCTURE-INTERSECT)
WORTH (0)
ALGS (ANY1OF (TYPE NONRECURSIVE QUICK OPAQUE (INTERSECTION BA1 BA2))
[TYPE NONRECURSIVE (ANY1OF [SUBSET BA1 (FUNCTION (LAMBDA
(Z)
(APPLYB (QUOTE
STRUCTURE-MEMB)
(QUOTE ALGS)
Z BA2]
(SUBSET BA2 (FUNCTION (LAMBDA
(Z)
(APPLYB (QUOTE
STRUCTURE-MEMB)
(QUOTE ALGS)
Z BA1]
(TYPE RECURSIVE (PROGN [COND ((SETQ BA4 (APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
NIL BA2))
(SETQ BA1 (APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
BA4 BA1))
(SETQ BA1 (APPLYB (QUOTE SET-STRUC-INTERSECT)
(QUOTE ALGS)
BA1 BA2))
(AND (APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
BA4 BA2)
(APPLYB (QUOTE SET-STRUC-INSERT)
BA4 BA1]
BA1)))
UP (SET-STRUC-IN-DOM-OF)
D-R (OSET (SET-STRUC SET-STRUC SET-STRUC)))
(PUTPROPS STRUCTURE GENL (OBJECT)
INT [IPLUS (IMATRIX (1 2)
(3))
[COND ([SOME (INT-PREDS)
(FUNCTION (LAMBDA (P)
(AND (CDDAR (GETB P (QUOTE D-R)))
[EVERY (CDR BA1)
(FUNCTION (LAMBDA
(X)
(EVERY (CDR BA1)
(FUNCTION
(LAMBDA
(Y)
(APPLYB
P
(QUOTE ALGS)
X Y]
(PROG1 P (CPRIN1 46 " The chosen predicate is " P
CRLF]
371
(FIX (RMUL (DOTPROD (LIST .6 .3 .1)
(GETB P (QUOTE WORTH)))
(LENGTH BA1)
30)))
(NIL (* Each pair of elements satisfies the same interesting predicate P
(for some P]
[COND ([SOME (INT-PREDS)
(FUNCTION (LAMBDA (P)
(AND [NULL (CDDAR (GETB P (QUOTE D-R]
(CDAR (GETB P (QUOTE D-R)))
[EVERY (CDR BA1)
(FUNCTION (LAMBDA (X)
(APPLYB (QUOTE P)
(QUOTE ALGS)
X]
(PROG1 P (CPRIN1 46 " Chosen Pred is " P CRLF]
370
(FIX (RMUL (DOTPROD (LIST .5 .3 .1)
(GETB P (QUOTE WORTH)))
(LENGTH BA1)
40)))
(NIL (* Each element satisfies the interesting predicate P (for some P]
(COND [(CDR BA1)
13
(MAX (CDR BA1)
(FUNCTION
(LAMBDA
(M1)
(DOTPROD (.9 .1)
(COND
((GETB M1 (QUOTE WORTH)))
((LIST (FAN [COND ((GETB M1 (QUOTE GENL)))
[(SUBSET CONCEPTS
(FUNCTION
(LAMBDA
(KC)
(MEMBER M1
(GETB KC
(QUOTE EXS]
((LIST (QUOTE ANYB]
(QUOTE INT)
M1]
(NIL (* There is 1 very interesting element in the set]
SPEC (MULT-STRUC NONMULT-STRUC EMPTY-STRUC)
IN-DOM-OF (STRUCTURE-INSERT STRUCTURE-MEMB STRUCTURE-DELETE STRUCTURE-EQUAL)
WORTH (10 3 999)
VIEW [ANY-OF (COND ([SOME [DREVERSE (CDR (FMEMB (QUOTE STRUCTURE)
(RIPPLE BA1 (QUOTE GENL]
(FUNCTION (LAMBDA (Z)
(IS-CON (SETQ GTEMP44 (GLUE Z (QUOTE INSERT]
(* BA1 is the name of the type we wish to convert the given to)
(* BA2 is the given structure to be converted)
(* BA3 is the name of the given structure's type)
(SETQ GTEMP43 (APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
T
(APPLYB GTEMP44 (QUOTE ALGS)
T NIL)))
(* GTEMP3 IS THUS INITIALIZED)
[MAPC (REVERSE (CDR BA2))
(FUNCTION (LAMBDA (Z)
(SETQ GTEMP43 (APPLYB GTEMP44 (QUOTE ALGS)
Z GTEMP43]
(* If we didn't know about MAPC, we would have to use BA3-member to pull
elements off BA2 one at a time)
(LIST GTEMP43]
DEFN (ANY-OF NIL)
DEFN-NOT (ANY-OF (NLISTP BA1)))
(PUTPROPS STRUCTURE-DELETE GENL (OPERATION)
WORTH (0)
ALGS [ANY1OF (TYPE NONRECURSIVE (OR [AND (SETQ GTEMP7 (FMEMB BA1 (CDR BA2)))
(COND ((CDR GTEMP7)
(RPLACA GTEMP7 (APPEND (CADR GTEMP7)))
(RPLACD GTEMP7 (CDDR GTEMP7)))
((RPLACD BA2 (DREMOVE BA1 (CDR BA2]
BA2))
(TYPE RECURSIVE (COND ((NULL (SETQ BA3 (APPLYB (QUOTE FIRST)
(QUOTE ALGS)
BA2)))
BA2)
(T (RPLACD BA2 (CDDR BA2))
(COND ((APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
BA1 BA3)
BA2)
(T (APPLYB (QUOTE BAG-STRUC-INSERT)
(QUOTE ALGS)
BA3
(APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
BA1 BA2]
UP (STRUCTURE-IN-DOM-OF OPERATION)
INV (TYPE NONRECURSIVE TRANSFORM (PROGN (ARG-SUBST (QUOTE BA1)
(RAND-MEMB (UNDO-INIT CS-P GEXISTING))
(QUOTE BA2)
(RAND-THING))
(APPLYB (QUOTE STRUCTURE-INSERT)
(QUOTE ALGS)
(OR (AND (LISTP BA1)
(EQ (CAR BA1)
(QUOTE APPLYB))
(EVAL (SUBST (QUOTE INV)
(QUOTE ALGS)
BA1)))
BA1)
(OR (AND (LISTP BA2)
(EQ (CAR BA2)
(QUOTE APPLYB))
(EVAL (SUBST (QUOTE INV)
(QUOTE ALGS)
BA2)))
BA2)
BA3)))
D-R (OSET (ANYTHING STRUCTURE STRUCTURE))
SPEC (BAG-STRUC-DELETE LIST-STRUC-DELETE OSET-STRUC-DELETE SET-STRUC-DELETE)
IN-DOM-OF (COMPOSE))
(PUTPROPS STRUCTURE-DIFF GENL (OPERATION)
WORTH (0)
ALGS [ANY1OF (TYPE NONRECURSIVE OPAQUE QUICK (AND (LISTP BA1)
(LISTP BA2)
(EQ (CAR BA1)
(CAR BA2))
(SUBSET BA1
(FUNCTION
(LAMBDA
(Z)
(PROG1 (EQUAL Z (CAR BA2))
(SETQ BA2 (CDR BA2]
UP (STRUCTURE-IN-DOM-OF OPERATION)
INV (TYPE NONRECURSIVE TRANSFORM (APPLYB (QUOTE STRUCTURE-DIFF)
(QUOTE ALGS)
BA2 BA1 BA3))
D-R (OSET (STRUCTURE STRUCTURE STRUCTURE))
SPEC (SET-STRUC-DIFF)
IN-DOM-OF (COMPOSE))
(PUTPROPS STRUCTURE-EQUAL GENL (OBJ-EQUAL)
WORTH (0)
UP (STRUCTURE-IN-DOM-OF PREDICATE)
D-R (OSET (STRUCTURE STRUCTURE TRUTH-VAL)))
(PUTPROPS STRUCTURE-EXS GENL [ANYB-EXS (OR-RUN: (LIST (RIPPLE1 (QUOTE STRUCTURE)
(QUOTE EXS)
(QUOTE GENL]
FILLIN2 (APPEND (FIL-STRUC-P (QUOTE EXS)))
WORTH (0))
(PUTPROPS STRUCTURE-EXS-BDY GENL [ANYB-EXS-BDY (OR-RUN: (LIST (RIPPLE1 (QUOTE STRUCTURE)
(QUOTE EXS-BDY)
(QUOTE GENL]
FILLIN2 [APPEND (FIL-STRUC-P (QUOTE EXS-BDY))
(PROG1 NIL [ADD-CANDS (LIST (CONS (AVG2 DO-THRESH CS-INT)
(SETQ GTEMP11 (LIST (QUOTE CHECK)
CS-B
(QUOTE EXS]
(MAPC PAST (FUNCTION (LAMBDA (Z)
(AND (EQUAL (CAR Z)
GTEMP11)
(ATTACH (QUOTE INCONCLUSIVELY)
(CAR Z]
WORTH (0))
(PUTPROPS STRUCTURE-INSERT GENL (OPERATION)
WORTH (0)
ALGS [ANY1OF (TYPE NONRECURSIVE CASES BRANCH (AND (SETQ BA2 (STRUCTYP? BA1 BA2 BA3))
[IS-CON (SETQ GTEMP3
(GLUE GTEMP3 (QUOTE INSERT]
(APPLYB GTEMP3 (QUOTE ALGS)
BA1 BA2]
UP (STRUCTURE-IN-DOM-OF OPERATION)
D-R (OSET (ANYTHING STRUCTURE STRUCTURE))
SPEC (BAG-STRUC-INSERT LIST-STRUC-INSERT OSET-STRUC-INSERT SET-STRUC-INSERT)
IN-DOM-OF (COMPOSE))
(PUTPROPS STRUCTURE-INTERSECT GENL (OPERATION)
WORTH (0)
UP (STRUCTURE-IN-DOM-OF OPERATION)
ALGS [ANY1OF (TYPE NONRECURSIVE CASES BRANCH
(AND (SETQ BA2 (STRUCTYP? BA1 BA2 BA3))
[SETQ GTEMP3 (CAR (SOME (REVERSE (RIPPLE GTEMP3 (QUOTE GENL)))
(FUNCTION (LAMBDA
(G)
(IS-CON
(GLUE G (QUOTE INTERSECT]
(NEQ GTEMP3 (QUOTE STRUCTURE-INTERSECT))
(APPLYB (GLUE GTEMP3 (QUOTE INTERSECT))
(QUOTE ALGS)
BA1 BA2]
D-R (OSET (STRUCTURE STRUCTURE STRUCTURE))
SPEC (SET-STRUC-INTERSECT BAG-STRUC-INTERSECT LIST-STRUC-INTERSECT OSET-STRUC-INTERSECT)
IN-DOM-OF (COMPOSE))
(PUTPROPS STRUCTURE-MEMB GENL (OPERATION)
WORTH (0)
ALGS [ANY1OF [TYPE NONRECURSIVE QUICK CASES (COND ((AND BA1 BA2)
(MEMBER BA1 (CDR BA2)))
(BA2 (CADR BA2))
(BA1 (LIST (QUOTE CLASS)
BA1]
[TYPE NONRECURSIVE CASES (COND [(NOT BA1)
(AND (LISTP BA2)
(RAND-MEMB (CDR BA2]
((LISTP BA2)
(MEMBER BA1 (CDR BA2)))
[(NOT BA2)
(APPLYB (QUOTE STRUCTURE-INSERT)
(QUOTE ALGS)
BA1
(RAND-MEMB (EXS STRUCTURE]
((ATOM BA2)
(APPLYB (QUOTE STRUCTURE-INSERT)
(QUOTE ALGS)
BA1
(RAND-MEMB (GETB BA2 (QUOTE EXS]
[TYPE RECURSIVE (AND BA1 (SETQ BA3 (RAND-MEMB (CDR BA2)))
(OR (APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
BA1 BA3)
(APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
BA1
(APPLYB (QUOTE STRUCTURE-DELETE)
(QUOTE ALGS)
BA3 BA2]
(TYPE QUICK OPAQUE (MEMBER BA1 BA2))
(TYPE ITERATIVE (AND BA1 (SOME (CDR BA2)
(FUNCTION (LAMBDA (Z)
(APPLYB (QUOTE OBJ-EQUAL)
(QUOTE ALGS)
BA1 Z]
UP (STRUCTURE-IN-DOM-OF OPERATION)
INV [TYPE NONRECURSIVE CASES (COND ((AND BA1 (LISTP BA2))
(NOT (APPLYB (QUOTE STRUCTURE-MEMB)
(QUOTE ALGS)
BA1 BA2)))
((AND (NOT BA1)
(LISTP BA2))
(PROG (Z)
L1
(SETQ Z (RAND-THING))
(COND ((FMEMB Z BA2)
(GO L1)))
(RETURN Z)))
((AND BA1 (ATOM BA2))
(APPLYB (QUOTE STRUCTURE-INSERT)
(QUOTE INV)
BA1
(RAND-MEMB (OR (GETB BA2 (QUOTE EXS))
(APPLY* (QUOTE EXS)
BA2)
(EXS STRUCTURE]
D-R (OSET (ANYTHING STRUCTURE TRUTH-VAL))
IN-DOM-OF (COMPOSE))
(PUTPROPS TRUTH-VAL GENL (OBJECT)
IN-RAN-OF (PREDICATE)
WORTH (0)
DEFN [ANY-OF (TYPE NONRECURSIVE CASES (COND ((EQUAL BA1 T))
((EQUAL BA1 NIL))
(T NIL]
ALGS [ANY1OF (TYPE NONRECURSIVE CASES (COND (BA1 T)
(T NIL])
(PUTPROPS UNORD-OBJ GENL (OBJECT)
SPEC (SET-STRUC BAG-STRUC)
WORTH (0))
(PUTPROPS UNORD-OBJ-EXS GENL (OBJECT-EXS)
WORTH (0)
CHECK1 [AND (GETHASH [SETQ GTEMP4 (PACK (LIST CS-B (QUOTE -INSERT]
HCON)
(SETQ GEXISTING (SETB CS-B (QUOTE EXS)
(APPEND (GETB (QUOTE ANYB-EXS)
(QUOTE INIT))
(MAPCAR (GETB CS-B (QUOTE EXS))
(FUNCTION (LAMBDA
(Z)
(CONS (CAR Z)
(SORT (CDR Z)
(QUOTE SORD])
(INIT-C)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA VECTOR STRUC PAIR OSET FORMAT CLASS BAG)
(ADDTOVAR NLAML WORTH VIEW UP TIES SUGG SPEC RESTRUC INV INTU INT-NOT INT INIT IN-RAN-OF IN-DOM-OF GENL FILLIN2
FILLIN1 FILLIN EXS-NOT-BDY EXS-NOT EXS-BDY EXS DEFN-NOT DEFN D-R CHECK2 CHECK1 CHECK ANAS ALGS)
]
(DECLARE: DONTCOPY
(FILEMAP (NIL (958 4050 (BAG 970 . 1019) (CLASS 1023 . 1076) (FORMAT 1080 . 1135) (IMATRIX 1139 . 1166) (INIT-C 1170
. 3821) (OSET 3825 . 3876) (PAIR 3880 . 3931) (STRUC 3935 . 3988) (VECTOR 3992 . 4047)) (9349 13562 (ALGS 9361 . 9444)
(ANAS 9448 . 9525) (CHECK 9529 . 10181) (CHECK1 10185 . 10242) (CHECK2 10246 . 10303) (D-R 10307 . 10358) (DEFN 10362
. 10808) (DEFN-NOT 10812 . 11041) (EXS 11045 . 11096) (EXS-BDY 11100 . 11159) (EXS-NOT 11163 . 11222) (EXS-NOT-BDY
11226 . 11293) (FILLIN 11297 . 11993) (FILLIN1 11997 . 12056) (FILLIN2 12060 . 12119) (GENL 12123 . 12173) (IN-DOM-OF
12177 . 12240) (IN-RAN-OF 12244 . 12307) (INIT 12311 . 12364) (INT 12368 . 12443) (INT-NOT 12447 . 12530) (INTU 12534
. 12611) (INV 12615 . 12698) (RESTRUC 12702 . 12761) (SPEC 12765 . 12815) (SUGG 12819 . 12896) (TIES 12900 . 12953)
(UP 12957 . 13006) (VIEW 13010 . 13500) (WORTH 13504 . 13559)))))
STOP